home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
clx.lha
/
clx
/
graphics.l
< prev
next >
Wrap
Lisp/Scheme
|
1988-09-12
|
16KB
|
438 lines
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;;; CLX drawing requests
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package 'xlib :use '(lisp))
(export '(
draw-point
draw-points
draw-line
draw-lines
draw-segments
draw-rectangle
draw-rectangles
draw-arc
draw-arcs
put-raw-image
get-raw-image))
(defvar *inhibit-appending* nil)
(defun draw-point (drawable gcontext x y)
;; Should be clever about appending to existing buffered protocol request.
(declare (type drawable drawable)
(type gcontext gcontext)
(type int16 x y))
(let ((display (drawable-display drawable)))
(with-display (display)
(force-gcontext-changes gcontext)
(writing-buffer-send (display)
(let* ((last-request-byte (display-last-request display))
(current-boffset buffer-boffset))
;; To append or not append, that is the question
(if (and (not *inhibit-appending*)
last-request-byte
;; Same request?
(= (aref-card8 buffer-bbuf last-request-byte) *x-polypoint*)
(progn ;; Set buffer pointers to last request
(set-buffer-offset last-request-byte)
;; same drawable and gcontext?
(or (compare-request (4)
(data 0)
(drawable drawable)
(gcontext gcontext))
(progn ;; If failed, reset buffer pointers
(set-buffer-offset current-boffset)
nil))))
;; Append request
(progn
;; Set new request length
(card16-put 2 (index+ 1 (index-ash (index- current-boffset last-request-byte)
-2)))
(set-buffer-offset current-boffset :sizes 16)
(put-items (0) ; Insert new point
(int16 x y))
(setf (display-boffset display) (index+ buffer-boffset 4)))
;; New Request
(progn
(put-items (4)
(code *x-polypoint*)
(data 0) ;; Relative-p false
(length 4)
(drawable drawable)
(gcontext gcontext)
(int16 x y))
(incf (buffer-request-number display))
(setf (buffer-last-request display) buffer-boffset)
(setf (display-boffset display) (index+ buffer-boffset 16)))))))
(display-invoke-after-function display)))
(defun draw-points (drawable gcontext points &optional relative-p)
(declare (type drawable drawable)
(type gcontext gcontext)
(type sequence points) ;(repeat-seq (integer x) (integer y))
(type boolean relative-p))
(with-buffer-request ((drawable-display drawable) *x-polypoint* :gc-force gcontext)
((data boolean) relative-p)
(drawable drawable)
(gcontext gcontext)
((sequence :format int16) points)))
(defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p)
;; Should be clever about appending to existing buffered protocol request.
(declare (type drawable drawable)
(type gcontext gcontext)
(type int16 x1 y1 x2 y2)
(type boolean relative-p))
(let ((display (drawable-display drawable)))
(when relative-p
(incf x2 x1)
(incf y2 y1))
(with-display (display)
(force-gcontext-changes gcontext)
(writing-buffer-send (display)
(let* ((last-request-byte (display-last-request display))
(current-boffset buffer-boffset))
;; To append or not append, that is the question
(if (and (not *inhibit-appending*)
last-request-byte
;; Same request?
(= (aref-card8 buffer-bbuf last-request-byte) *x-polysegment*)
(progn ;; Set buffer pointers to last request
(set-buffer-offset last-request-byte :sizes (16 32))
;; same drawable and gcontext?
(or (compare-request (4)
(drawable drawable)
(gcontext gcontext))
(progn ;; If failed, reset buffer pointers
(set-buffer-offset current-boffset :sizes (16 32))
nil))))
;; Append request
(progn
;; Set new request length
(card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte)
-2)))
(set-buffer-offset current-boffset :sizes 16)
(put-items (0) ; Insert new point
(int16 x1 y1 x2 y2))
(setf (display-boffset display) (index+ buffer-boffset 8)))
;; New Request
(progn
(put-items (4)
(code *x-polysegment*)
(length 5)
(drawable drawable)
(gcontext gcontext)
(int16 x1 y1 x2 y2))
(incf (buffer-request-number display))
(setf (buffer-last-request display) buffer-boffset)
(setf (display-boffset display) (index+ buffer-boffset 20)))))))
(display-invoke-after-function display)))
(defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex))
(declare (type drawable drawable)
(type gcontext gcontext)
(type sequence points) ;(repeat-seq (integer x) (integer y))
(type boolean relative-p fill-p)
(type (member :complex :non-convex :convex) shape))
(if fill-p
(fill-polygon drawable gcontext points relative-p shape)
(with-buffer-request ((drawable-display drawable) *x-polyline* :gc-force gcontext)
((data boolean) relative-p)
(drawable drawable)
(gcontext gcontext)
((sequence :format int16) points))))
;; Internal function called from DRAW-LINES
(defun fill-polygon (drawable gcontext points relative-p shape)
;; This is clever about appending to previous requests. Should it be?
(declare (type drawable drawable)
(type gcontext gcontext)
(type sequence points) ;(repeat-seq (integer x) (integer y))
(type boolean relative-p)
(type (member :complex :non-convex :convex) shape))
(with-buffer-request ((drawable-display drawable) *x-fillpoly* :gc-force gcontext)
(drawable drawable)
(gcontext gcontext)
((member8 :complex :non-convex :convex) shape)
(boolean relative-p)
((sequence :format int16) points)))
(defun draw-segments (drawable gcontext segments)
(declare (type drawable drawable)
(type gcontext gcontext)
;; (repeat-seq (integer x1) (integer y1) (integer x2) (integer y2)))
(type sequence segments))
(with-buffer-request ((drawable-display drawable) *x-polysegment* :gc-force gcontext)
(drawable drawable)
(gcontext gcontext)
((sequence :format int16) segments)))
(defun draw-rectangle (drawable gcontext x y width height &optional fill-p)
;; Should be clever about appending to existing buffered protocol request.
(declare (type drawable drawable)
(type gcontext gcontext)
(type int16 x y)
(type card16 width height)
(type boolean fill-p))
(let ((display (drawable-display drawable))
(request (if fill-p *x-polyfillrectangle* *x-polyrectangle*)))
(with-display (display)
(force-gcontext-changes gcontext)
(writing-buffer-send (display)
(let* ((last-request-byte (display-last-request display))
(current-boffset buffer-boffset))
;; To append or not append, that is the question
(if (and (not *inhibit-appending*)
last-request-byte
;; Same request?
(= (aref-card8 buffer-bbuf last-request-byte) request)
(progn ;; Set buffer pointers to last request
(set-buffer-offset last-request-byte)
;; same drawable and gcontext?
(or (compare-request (4)
(drawable drawable)
(gcontext gcontext))
(progn ;; If failed, reset buffer pointers
(set-buffer-offset current-boffset)
nil))))
;; Append request
(progn
;; Set new request length
(card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte)
-2)))
(set-buffer-offset current-boffset :sizes 16)
(put-items (0) ; Insert new point
(int16 x y)
(card16 width height))
(setf (display-boffset display) (index+ buffer-boffset 8)))
;; New Request
(progn
(put-items (4)
(code request)
(length 5)
(drawable drawable)
(gcontext gcontext)
(int16 x y)
(card16 width height))
(incf (buffer-request-number display))
(setf (buffer-last-request display) buffer-boffset)
(setf (display-boffset display) (index+ buffer-boffset 20)))))))
(display-invoke-after-function display)))
(defun draw-rectangles (drawable gcontext rectangles &optional fill-p)
(declare (type drawable drawable)
(type gcontext gcontext)
;; (repeat-seq (integer x) (integer y) (integer width) (integer height)))
(type sequence rectangles)
(type boolean fill-p))
(with-buffer-request ((drawable-display drawable)
(if fill-p *x-polyfillrectangle* *x-polyrectangle*)
:gc-force gcontext)
(drawable drawable)
(gcontext gcontext)
((sequence :format int16) rectangles)))
(defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p)
;; Should be clever about appending to existing buffered protocol request.
(declare (type drawable drawable)
(type gcontext gcontext)
(type int16 x y)
(type card16 width height)
(type angle angle1 angle2)
(type boolean fill-p))
(let ((display (drawable-display drawable))
(request (if fill-p *x-polyfillarc* *x-polyarc*)))
(with-display (display)
(force-gcontext-changes gcontext)
(writing-buffer-send (display)
(let* ((last-request-byte (display-last-request display))
(current-boffset buffer-boffset))
;; To append or not append, that is the question
(if (and (not *inhibit-appending*)
last-request-byte
;; Same request?
(= (aref-card8 buffer-bbuf last-request-byte) request)
(progn ;; Set buffer pointers to last request
(set-buffer-offset last-request-byte)
;; same drawable and gcontext?
(or (compare-request (4)
(drawable drawable)
(gcontext gcontext))
(progn ;; If failed, reset buffer pointers
(set-buffer-offset current-boffset)
nil))))
;; Append request
(progn
;; Set new request length
(card16-put 2 (index+ 3 (index-ash (index- current-boffset last-request-byte)
-2)))
(set-buffer-offset current-boffset :sizes 16)
(put-items (0) ; Insert new point
(int16 x y)
(card16 width height)
(angle angle1 angle2))
(setf (display-boffset display) (index+ buffer-boffset 12)))
;; New Request
(progn
(put-items (4)
(code request)
(length 6)
(drawable drawable)
(gcontext gcontext)
(int16 x y)
(card16 width height)
(angle angle1 angle2))
(incf (buffer-request-number display))
(setf (buffer-last-request display) buffer-boffset)
(setf (display-boffset display) (index+ buffer-boffset 24)))))))
(display-invoke-after-function display)))
(defun draw-arcs (drawable gcontext arcs &optional fill-p)
(declare (type drawable drawable)
(type gcontext gcontext)
;; (repeat-seq (integer x) (integer y) (integer width) (integer height)
(type sequence arcs)
;; (angle angle1) (angle angle2))
(type boolean fill-p))
(let* ((display (drawable-display drawable))
(size (display-size display))
(length (length arcs))
(request (if fill-p *x-polyfillarc* *x-polyarc*)))
(with-buffer-request ((drawable-display drawable) request :gc-force gcontext)
(drawable drawable)
(gcontext gcontext)
(progn
(card16-put 2 (+ (ash length -1) 3)) ; Set request length (in words)
(incf buffer-boffset 12) ; Position to start of data
(etypecase arcs
(list ;; Fast loop so ELT doesn't have to cdr down the list each time
(do ((arc arcs))
((endp arc)
(setf (buffer-boffset display) buffer-boffset))
(set-buffer-offset buffer-boffset :sizes (16))
(int16-put 0 (pop arc))
(int16-put 2 (pop arc))
(card16-put 4 (pop arc))
(card16-put 6 (pop arc))
(angle-put 8 (pop arc))
(angle-put 10 (pop arc))
(incf buffer-boffset 12)
(when (>= buffer-boffset size)
(setf (buffer-boffset display) buffer-boffset)
(buffer-flush display)
(setq buffer-boffset (display-boffset display)))))
(vector ;; Fast loop uses AREF instead of ELT
(do ((n 0 (+ n 6))
(length (length arcs)))
((> n length)
(setf (buffer-boffset display) buffer-boffset))
(set-buffer-offset buffer-boffset :sizes (16))
(int16-put 0 (aref arcs (+ n 0)))
(int16-put 2 (aref arcs (+ n 1)))
(card16-put 4 (aref arcs (+ n 2)))
(card16-put 6 (aref arcs (+ n 3)))
(angle-put 8 (aref arcs (+ n 4)))
(angle-put 10 (aref arcs (+ n 5)))
(incf buffer-boffset 12)
(when (>= buffer-boffset size)
(setf (buffer-boffset display) buffer-boffset)
(buffer-flush display)
(setq buffer-boffset (display-boffset display))))))))))
;; The following image routines are bare minimum. It may be useful to define
;; some form of "image" object to hide representation details and format
;; conversions. It also may be useful to provide stream-oriented interfaces
;; for reading and writing the data.
(defun put-raw-image (drawable gcontext data &key
(start 0)
(depth (required-arg depth))
(x (required-arg x))
(y (required-arg y))
(width (required-arg width))
(height (required-arg height))
(left-pad 0)
(format (required-arg format)))
;; Data must be a sequence of 8-bit quantities, already in the appropriate format
;; for transmission; the caller is responsible for all byte and bit swapping and
;; compaction. Start is the starting index in data; the end is computed from the
;; other arguments.
(declare (type drawable drawable)
(type gcontext gcontext)
(type sequence data) ; Sequence of integers
(type array-index start)
(type card8 depth left-pad) ;; required
(type int16 x y) ;; required
(type card16 width height) ;; required
(type (member :bitmap :xy-pixmap :z-pixmap) format))
(with-buffer-request ((drawable-display drawable) *x-putimage* :gc-force gcontext)
((data (member :bitmap :xy-pixmap :z-pixmap)) format)
(drawable drawable)
(gcontext gcontext)
(card16 width height)
(int16 x y)
(card8 left-pad depth)
(pad16 nil)
((sequence :format card8 :start start) data)))
(defun get-raw-image (drawable &key
data
(start 0)
(x (required-arg x))
(y (required-arg y))
(width (required-arg width))
(height (required-arg height))
(plane-mask #xffffffff)
(format (required-arg format))
(result-type '(vector card8)))
;; If data is given, it is modified in place (and returned), otherwise a new sequence
;; is created and returned, with a size computed from the other arguments and the
;; returned depth. The sequence is filled with 8-bit quantities, in transmission
;; format; the caller is responsible for any byte and bit swapping and compaction
;; required for further local use.
(declare (type drawable drawable)
(type (or null sequence) data) ;; sequence of integers
(type int16 x y) ;; required
(type card16 width height) ;; required
(type array-index start)
(type pixel plane-mask)
(type (member :xy-pixmap :z-pixmap) format))
(declare-values (sequence integer) depth visual)
(let ((display (drawable-display drawable))
seq depth visual)
(with-display (display)
(with-buffer-request (display *x-getimage* :no-after)
((data (member error :xy-pixmap :z-pixmap)) format)
(drawable drawable)
(int16 x y)
(card16 width height)
(card32 plane-mask))
(with-buffer-reply (display nil :sizes (8 32))
(setq depth (card8-get 1)
visual (resource-id-get 8))
(let ((length (* 4 (card32-get 4))))
(setq seq (sequence-get :result-type result-type :format card8
:length length :start start :data data)))))
(display-invoke-after-function display)
(values seq depth visual)))